home *** CD-ROM | disk | FTP | other *** search
/ PC World Interactive 7 / PC World Interactive 7.iso / program / pasprog.EXE / KARAKTER.PAS < prev    next >
Pascal/Delphi Source File  |  1980-01-10  |  10KB  |  467 lines
  1.  
  2.  
  3.  
  4.       program karakter_tanimlama;
  5.       uses
  6.       crt,graph,dos;
  7.  
  8.  
  9.       var
  10.       karakterler   : array [0..1023] of byte;
  11.       tablo_adresi_seg : word;
  12.       tablo_adresi_ofs : word;
  13.       a,ct          : byte;
  14.       kp            : char;
  15.       durum         : byte;
  16.       s             : string;
  17.       secilen_karakter : byte;
  18.       deneme           : byte;
  19.       target           : string[8];
  20.  
  21.  
  22.       procedure byte_to_string(ascii:byte);
  23.       begin
  24.       target:='00000000';
  25.       for a:=8 downto 1 do begin
  26.       if ascii and trunc(exp((a-1)*ln(2)))<>0 then target[9-a]:='1' else
  27.       target[9-a]:='0';
  28.       end;
  29.       end;
  30.  
  31.  
  32.  
  33.  
  34.  
  35.       procedure beep(a,b:integer);
  36.  
  37.       begin
  38.       sound(a);delay(b);nosound;
  39.       end;
  40.  
  41.  
  42.       procedure grafik;
  43.  
  44.       var
  45.       grDriver : Integer;
  46.       grMode   : Integer;
  47.       ErrCode  : Integer;
  48.       begin
  49.       grDriver := Detect;
  50.       InitGraph(grDriver,grMode,'c:\tp\bgi');
  51.       ErrCode := GraphResult;
  52.       if ErrCode <> grOk then
  53.       begin
  54.       clrscr;
  55.       writeln('grafik surucusu bulunamadi !');
  56.       halt(1);
  57.       end else
  58.       end;
  59.  
  60.  
  61.  
  62. procedure editor_penceresi_secilisi(st:byte);
  63. const
  64. x = 30;
  65. y = 300;
  66.  
  67. begin
  68. if st=1 then begin
  69.              setcolor(white);
  70.              rectangle(x-1,y-1,x+161,y+161);
  71.              end;
  72. if st=0 then begin
  73.              setcolor(black);
  74.              rectangle(x-1,y-1,x+161,y+161);
  75.              end;
  76. end;
  77.  
  78.  
  79. procedure karakter_tablosu_secilisi(st:byte);
  80. const
  81. x = 425;
  82. y = 55;
  83.  
  84. begin
  85. if st=1 then setcolor(white);
  86. rectangle(x-9,y-9,x+25*8+1,y+25*16+9);
  87. if st=0 then setcolor(black);
  88. rectangle(x-9,y-9,x+25*8+1,y+25*16+9);
  89. end;
  90.  
  91. procedure karakter_tablosu(x,y:integer);
  92.  
  93. var
  94. a,b,c:integer;
  95. begin
  96. c:=25;
  97. setcolor(white);
  98. setfillstyle(solidfill,blue);
  99.  
  100. bar(x-8,y-8,x+c*8,y+c*16+8);
  101. settextstyle(defaultfont,horizdir,2);
  102.  
  103.  
  104. for a:=0 to 7 do begin
  105. for b:=0 to 15 do begin
  106. outtextxy(x+a*c,y+b*c,chr(128+a*16+b));
  107. end;
  108. end;
  109. setcolor(lightmagenta);
  110. rectangle(x-8,y-8,x+c*8,y+c*16+8);
  111. settextstyle(triplexfont,0,3);
  112. setcolor(lightgray);
  113. outtextxy(x+1,y-49,'Karakter Tablosu');
  114. setcolor(lightgreen);
  115. outtextxy(x,y-50,'Karakter Tablosu');
  116. end;
  117.  
  118.  
  119. procedure editor_penceresi(x,y:integer);
  120.  
  121. var a,b,c:integer;
  122.  
  123. begin
  124. c:=18;
  125. setfillstyle(solidfill,blue);
  126. for b:=0 to 7 do begin
  127. for a:=0 to 7 do begin
  128. bar(x+a*20,y+b*20,x+a*20+c,y+b*20+c);
  129. end;
  130. end;
  131. setcolor(magenta);
  132. rectangle(x-2,y-2,x+160,y+160);
  133. end;
  134.  
  135. procedure karakter_tablosunu_tanimla;
  136.  
  137. const Vector = $1F;
  138. var src, dst : pointer;
  139. begin
  140.   src := ptr (MemW [0:Vector*4+2],MemW [0:Vector*4]);
  141.   dst := ptr (seg(karakterler), ofs(karakterler));
  142.   move (src^, dst^, sizeof(karakterler));
  143.   MemW [0:Vector*4] := Ofs (karakterler);
  144.   MemW [0:Vector*4+2] := Seg (karakterler);
  145. end;
  146.  
  147. procedure tablo_reset;
  148. const Vector = $1F;
  149. begin
  150.   MemW [0:Vector*4] := tablo_adresi_ofs;
  151.   MemW [0:Vector*4+2] := tablo_adresi_seg;
  152. end;
  153.  
  154.  
  155. procedure editor_imleci(x,y:integer;st:byte);
  156.  
  157. begin
  158.  
  159. if st=1 then begin
  160.              setfillstyle(solidfill,white);
  161.              bar(x,y,x+18,y+18);
  162.              end;
  163.  
  164. if st=0 then begin
  165.              setfillstyle(solidfill,blue);
  166.              bar(x,y,x+18,y+18);
  167.              end;
  168.  
  169.  
  170. end;
  171.  
  172. procedure karakter_imleci(x,y:integer);
  173.  
  174. begin
  175. setcolor(green);
  176. repeat
  177.       setrgbpalette(green,random(64),random(64),random(64));
  178.       rectangle(x-2,y-2,x+17,y+17);
  179. until (keypressed) or (kp=#9);
  180.  
  181. setcolor(blue);
  182. rectangle(x-2,y-2,x+17,y+17);
  183. end;
  184.  
  185. procedure karakteri_buyut(x,y:integer;karakter:byte);
  186.  
  187. begin
  188.  
  189. for ct:=0 to 7 do begin
  190.                   byte_to_string(karakterler[(karakter-128)*8+ct]);
  191.                   a:=1;
  192.                   repeat
  193.                   if target[a]='1' then editor_imleci(x+(a-1)*20,y,1);
  194.                   if target[a]='0' then editor_imleci(x+(a-1)*20,y,0);
  195.                   inc(a);
  196.                   until a=9;
  197.                   y:=y+20;
  198.                   end;
  199.  
  200. end;
  201.  
  202. procedure define;
  203. var a,b:byte;
  204. X,Y:INTEGER;
  205. begin
  206. settextstyle(defaultfont,0,1);
  207. for b:=0 to 7 do begin
  208. target:='00000000';
  209. for a:=0 to 7 do begin
  210. if getpixel(40+a*20,310+b*20)=white then target[a+1]:='1';
  211. if getpixel(40+a*20,310+b*20)=blue then target[a+1]:='0';
  212. end;
  213. deneme:=0;
  214. for ct:=0 to 7 do begin
  215. if target[8-ct]='1' then deneme:=deneme+trunc(exp(ct*ln(2))) else begin end;
  216. end;
  217. karakterler[(secilen_karakter-128)*8+b]:=deneme;
  218. karakter_tablosunu_tanimla;
  219.  
  220.     setfillstyle(solidfill,black);
  221.     bar(280,340,310,365);
  222.     settextstyle(defaultfont,horizdir,3);
  223.     setcolor(yellow);
  224.     outtextxy(280,340,chr(secilen_karakter));
  225.  
  226.  
  227. end;
  228. end;
  229.  
  230. procedure karakter_tablosunu_kaydet;
  231.  
  232. var f : file;
  233.     w: word;
  234. begin
  235. assign(f,'C:\karakter.tan');
  236. rewrite (f,1);
  237. blockwrite (f,karakterler,sizeof(karakterler),w);
  238. close(f);
  239. end;
  240.  
  241. procedure karakter_tablosunu_yukle;
  242.  
  243. var f : file;
  244.     w: word;
  245. begin
  246. assign(f,'C:\karakter.tan');
  247. reset(f,1);
  248. blockread(f,karakterler,sizeof(karakterler),w);
  249. close(f);
  250. karakter_tablosunu_tanimla;
  251. karakter_tablosu(425,55);
  252. end;
  253.  
  254.  
  255.  
  256. procedure editor(karakter:byte);
  257.  
  258. var x,y:integer;
  259.  
  260. begin
  261. x:=30;y:=300;
  262. editor_penceresi_secilisi(1);
  263. karakteri_buyut(x,y,karakter);
  264. define;
  265.  
  266.  
  267. x:=30;y:=300;
  268. editor_imleci(x,y,1);
  269. kp:=#0;
  270.  
  271. repeat;
  272. define;
  273. kp:=readkey;
  274. setfillstyle(solidfill,black);
  275. if (kp='Y') or (kp='y') then durum:=1;
  276. if (kp='S') or (kp='s') then durum:=0;
  277. if (kp='K') or (kp='k') then karakter_tablosunu_kaydet;
  278. if (kp='L') or (kp='l') then karakter_tablosunu_yukle;
  279.  
  280. editor_imleci(x,y,durum);
  281. if kp=#0 then case readkey of
  282.  
  283.     'K' : x:=x-20;
  284.     'M' : x:=x+20;
  285.     'H' : y:=y-20;
  286.     'P' : y:=y+20;
  287.  
  288.  
  289.  
  290.  
  291.     end;
  292.  
  293.     if x<30 then x:=30;
  294.     if y<300 then y:=300;
  295.     if x>170 then x:=170;
  296.     if y>440 then y:=440;
  297.  
  298.     editor_imleci(x,y,1);
  299.  
  300.  
  301. until kp=#9;
  302.  
  303. editor_penceresi_secilisi(0);
  304. end;
  305.  
  306.  
  307. procedure karakter_secme;
  308.  
  309. var x,y:integer;
  310. begin
  311. x:=450;y:=55;
  312. karakter_tablosu_secilisi(1);
  313.     settextstyle(defaultfont,horizdir,3);
  314.     setcolor(yellow);
  315.     outtextxy(280,340,chr(trunc(128+(x-425)/25*16+(y-55)/25)));
  316.     str((trunc(128+(x-425)/25*16+(y-55)/25)),s);
  317.     secilen_karakter:=(trunc(128+(x-425)/25*16+(y-55)/25));
  318.     settextstyle(triplexfont,horizdir,4);
  319.     outtextxy(260,415,s);
  320.     karakteri_buyut(30,300,secilen_karakter);
  321.  
  322. repeat;
  323. karakter_imleci(x,y);
  324. kp:=readkey;
  325. if (kp='K') or (kp='k') then karakter_tablosunu_kaydet;
  326.     setfillstyle(solidfill,black);
  327.     bar(280,340,310,365);
  328.     bar(260,425,320,450);
  329. if kp=#0 then case readkey of
  330.  
  331.          'K' : x:=x-25;
  332.          'M' : x:=x+25;
  333.          'H' : y:=y-25;
  334.          'P' : y:=y+25;
  335.  
  336.  
  337.  
  338.              end else if (kp='c') or (kp='C') or (kp=#27) then begin
  339.                             closegraph;
  340.                             writeln('karakter tanimlama programindan
  341.                             ciktiniz');
  342.                             tablo_reset;
  343.                             halt(0);
  344.  
  345.                             end;
  346.  
  347.     if x<425 then x:=425;
  348.     if y<55 then y:=55;
  349.     if x>600 then x:=600;
  350.     if y>430 then y:=430;
  351.  
  352.     settextstyle(defaultfont,horizdir,3);
  353.     setcolor(yellow);
  354.     outtextxy(280,340,chr(trunc(128+(x-425)/25*16+(y-55)/25)));
  355.     str((trunc(128+(x-425)/25*16+(y-55)/25)),s);
  356.     secilen_karakter:=(trunc(128+(x-425)/25*16+(y-55)/25));
  357.     karakteri_buyut(30,300,secilen_karakter);
  358.  
  359.     settextstyle(triplexfont,horizdir,4);
  360.     outtextxy(260,415,s);
  361.     karakter_imleci(x,y);
  362.     setfillstyle(solidfill,black);
  363.     bar(280,340,310,365);
  364.     bar(260,425,320,450);
  365.  
  366.  
  367.     if kp=#9 then begin end;
  368. until kp=#9;
  369.  
  370.     settextstyle(defaultfont,horizdir,3);
  371.     setcolor(yellow);
  372.     outtextxy(280,340,chr(trunc(128+(x-425)/25*16+(y-55)/25)));
  373.     str((trunc(128+(x-425)/25*16+(y-55)/25)),s);
  374.     secilen_karakter:=(trunc(128+(x-425)/25*16+(y-55)/25));
  375.     settextstyle(triplexfont,horizdir,4);
  376.     outtextxy(260,415,s);
  377. karakter_tablosu_secilisi(0);
  378.  
  379. end;
  380.  
  381. procedure reklam(x,y:integer);
  382.  
  383. begin
  384. setcolor(white);
  385. settextstyle(triplexfont,horizdir,2);
  386. outtextxy(x+1,y+1,'KARAKTER TANIMLAMA PROGRAMI');
  387. setcolor(magenta);
  388. settextstyle(triplexfont,horizdir,2);
  389. outtextxy(x,y,'KARAKTER TANIMLAMA PROGRAMI');
  390.  
  391. setcolor(lightred);
  392. settextstyle(triplexfont,horizdir,1);
  393. outtextxy(x,y+50,'Bu program Cenk TARHAN tarafindan');
  394. outtextxy(x,y+70,'PCWorld/Turkiye Programlama Sanati');
  395. outtextxy(x,y+90,'Eki icin yazilmistir...');
  396.  
  397. setcolor(red);
  398. settextstyle(triplexfont,horizdir,1);
  399. x:=x-1;y:=y-1;
  400. outtextxy(x,y+50,'Bu program Cenk TARHAN tarafindan');
  401. outtextxy(x,y+70,'PCWorld/Turkiye Programlama Sanati');
  402. outtextxy(x,y+90,'Eki icin yazilmistir...');
  403.  
  404.  
  405. end;
  406.  
  407. procedure kullanim(x,y:integer);
  408.  
  409. begin
  410. setcolor(lightgreen);
  411. settextstyle(triplexfont,horizdir,2);
  412. outtextxy(x,y,'[ Y ] ... Yazma modu');
  413. outtextxy(x,y+20,'[ S ] ... Silme modu');
  414. outtextxy(x,y+40,'[ L ] ... Diskten dosya yukleme');
  415. outtextxy(x,y+60,'[ K ] ... Diske dosya kaydetme');
  416. outtextxy(x,y+80,'[ C ] ... Programdan cikis');
  417. end;
  418.  
  419. procedure ornekleme_bolgesi(x,y:integer);
  420.  
  421. begin
  422. setcolor(magenta);
  423. rectangle(220,298,370,460);
  424. line(220,330,370,330);
  425. rectangle(220,380,370,415);
  426. settextstyle(triplexfont,horizdir,1);
  427. setcolor(lightblue);
  428. outtextxy(x+1,y+1,' Karakter :');
  429. setcolor(blue);
  430. outtextxy(x,y,' Karakter :');
  431.  
  432.  
  433. setcolor(lightblue);
  434. outtextxy(x+1,y+86,'ASCII Kodu :');
  435. setcolor(blue);
  436. outtextxy(x,y+85,'ASCII Kodu :');
  437.  
  438. end;
  439.  
  440.  
  441.  
  442. { ana programin baslangici }
  443.  
  444. begin
  445.   tablo_adresi_ofs := MemW [0:$1f*4];
  446.   tablo_adresi_seg := MemW [0:$1f*4+2];
  447.  
  448. grafik;
  449. setcolor(darkgray);
  450. rectangle(0,0,639,479);
  451. karakter_tablosunu_tanimla;
  452. karakter_tablosu(425,55);
  453. editor_penceresi(30,300);
  454. editor_imleci(30,300,2);
  455. ornekleme_bolgesi(230,300);
  456. kullanim(30,180);
  457. reklam(10,5);
  458. repeat
  459. karakter_secme;
  460. kp:=#0;
  461. editor(secilen_karakter);
  462. karakter_tablosu(425,55);
  463. until (kp='c') or (kp='C');
  464. closegraph;
  465. writeln('karakter tanimlama programindan ciktiniz');
  466. tablo_reset;
  467. end.